home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DATETIME.SWG / 0039_Set Date-Time Routine.pas < prev    next >
Pascal/Delphi Source File  |  1994-02-09  |  4KB  |  115 lines
  1.  
  2. {Created by Carlos Beguinge, Sept 12, 1993}
  3. {Program to get the systems date using [GetDate] and allowing you to
  4.   change the date using [SetDate]. Feel free to incorporated into any
  5.   other code, and change it as you wish... Enjoy.}
  6. {P.S. Any changes made to make this code better please post it back to me
  7.   outlining the changes, Thank you.}
  8.  
  9. uses Dos, Crt;
  10.  
  11. const
  12.   days : array [0..6] of String[9] =         {Array of Weekdays set here}
  13.     ('Sunday','Monday','Tuesday',
  14.      'Wednesday','Thursday','Friday',
  15.      'Saturday');
  16. var
  17.   y, m, d, dow, I, Code : Word;              {Setting the variables here}
  18.   changedt, cch : Char;
  19.   flagd, flagm, flagy : boolean;
  20.   ch : String;
  21.  
  22. procedure start(Code: Word); Forward;        {To allow to go forward in a }
  23.                                              {procedure. Used for Error   } 
  24.                                              {Checking.                   }
  25.  
  26. procedure compute;                           {Called from procedure Start }
  27. begin                                        {Moves the numeric string to }
  28.   Val(ch, I, Code);                          {numeric value. then checks  }
  29.     if code <> 0 then                        {for errors. if error true   }
  30.     begin                                    {then Call procedure Start   }
  31.       clrscr;
  32.       Writeln('Error in Date Statement', 'Press any key to Start Again ');
  33.       readln;
  34.       start(Code);
  35.     end;                                     {Else Process Month, Day, and}
  36.     if (flagm = false) then                  {Year.                       }
  37.     begin
  38.       m := I;
  39.       flagm := true;
  40.       write(cch);
  41.       cch :=#0;
  42.     end;
  43.     if (flagd = false) and (cch > #0) then
  44.     begin
  45.       d := I;
  46.       flagd := true;
  47.       write(cch);
  48.       cch :=#0;
  49.       end;
  50.     if (flagy = false) and ( cch > #0) then
  51.     begin
  52.       y := I;
  53.       flagy := true;
  54.       cch :=#13;
  55.     end;
  56.   ch := '';
  57. end;
  58.  
  59. procedure ResetVars;                         {Called from procedure Start }
  60. begin                                        {Resets all variable.        }
  61.   clrscr;
  62.   Code :=0;
  63.   d :=0;
  64.   m :=0;
  65.   y :=0;
  66.   flagd := false;
  67.   flagm := false;
  68.   flagy := false;
  69.   ch :='';
  70.   cch := #0;
  71. end;
  72.  
  73. procedure start;                             {Called from Main Program    }
  74. begin                                        
  75.   ResetVars;                                 {Calls procedure ResetFields }
  76.   while (cch <> #13) do                      {Gets input from the keyboard}
  77.     begin                                    {until a "/" or "Enter is    }
  78.       cch := readkey;                        {pressed.                    }
  79.       while (cch <> #47) and (cch <> #13) do
  80.         begin
  81.           ch := ch + cch;                    {Adds the each numeric charac}
  82.           write(cch);                        {ter to the string variable  }
  83.           cch := readkey;
  84.         end;
  85.       compute;                               {Calls procedure Compute     }
  86.     end;
  87. end;
  88.  
  89. begin                                        {Main Program which calls    }
  90.   clrscr;                                    {procedure Start             }
  91.   GetDate(y,m,d,dow);
  92.   Writeln('Today is ', days[dow],', ',
  93.           m:0, '/', d:0, '/', y:0);
  94.   Writeln;
  95.   Write('Would you like to change this Date? ');
  96.   readln(changedt);
  97.   if upcase(changedt) ='Y' then
  98.      begin
  99.      start(Code);
  100.      clrscr;
  101.      SetDate(y,m,d);                         {Sets the Date if Changed    }
  102.      Writeln('Today is ', days[dow],', ',
  103.           m:0, '/', d:0, '/', y:0);
  104.      readln;
  105.      end
  106.      else
  107.      begin                                   {Date remains unchanged      }
  108.         Writeln('Today'#39's date Was NOT changed ');
  109.         Writeln('Today is ', days[dow],', ',
  110.            m:0, '/', d:0, '/', y:0);
  111.         readln;
  112.      end;
  113. end.
  114.  
  115.